home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 019 / ratio16a.arc / RSB3-RAT.MRG < prev   
Text File  |  1988-04-12  |  19KB  |  331 lines
  1. * ------------[ BLED merge (c) Ken Goosens ]-------------
  2. * Merge this against RSB3-CLR.MRG to produce RSB3MODS.MRG
  3. * RSB3-CLR.MRG:  Date 4-12-1988  Size 27306 bytes
  4. * ------------[ Created 04-12-1988 20:09:51 ]------------
  5. * REPLACING old line(s) by new
  6. * ------------[ BLED merge (c) Ken Goosens ]-------------
  7. * Merge this against TEST\RBBSSUB3.BAS to produce RBBSSUB3.BAS
  8. * TEST\RBBSSUB3.BAS:  Date 3-25-1988  Size 183747 bytes
  9. * ------------[ Created 04-12-1988 19:44:01 ]------------
  10. * REPLACING old line(s) by new
  11. * ------[ first line different ]------
  12. ' $linesize:132
  13. ' $title: 'RBBSSUB3.BAS CPC16-1A, Copyright 1986 - 88 by D. Thomas Mack'
  14. '  Copyright 1987 by D. Thomas Mack, all rights reserved.
  15. '  Name ...............: RBBSSUB3.BAS
  16. '  Written by .........: D. Thomas Mack
  17. '  First Released .....: June 29, 1986
  18. '  Subsequent Releases.: September 28, 1986, March 15, 1987, June 7, 1987
  19. '                      : November 15, 1987, March 27, 1988
  20. '  Copyright ..........: 1986, 1987, 1988
  21. '  Purpose.............: The Remote Bulletin Board System for the IBM PC,
  22. '                        RBBS-PC.BAS utilizes a lot of common subroutines.
  23. '                        Those that do not require error trapping are
  24. '                        incorporated within RBBSSUB2.BAS and RBBSSUB3.BAS
  25. '                        as separately callable subroutines in order to free
  26. '                        up as much code as possible within the 64K code
  27. '                        segment used by RBBS-PC.BAS.
  28. '  Parameters..........: Most parameters are passed via a COMMON statement.
  29. '
  30. ' Subroutine  Line               Function of Subroutine
  31. '   Name     Number
  32. '  ALLCAPS    58060   Convert a string to all upper case characters
  33. '  AMORPM     41500   Calculate the current time as AM or PM
  34. '  ANYBUT     59760   Determine where a "word" begins
  35. '  ASKMORE    59700   Check whether screen full
  36. '  ASKUSERS   64005   Ask users questions based on a script and save answers
  37. '  BUFFILE    58400   Write a file to the user quickly
  38. '  BUFSTRNG   58300   Write a string with imbedded CR/LF to the user quickly
  39. '  CALLOPT    58090   Set prompts based on the user's security
  40. '  CARRIER    42000   Test for Carrier present
  41. '  CHECKTIM   58070   Test to insure that users don't exceed their time
  42. '  CHKNARY    58180   Check for the occurance of a string in an array
  43. '  CHKNEWBUL  58110   Check for new bulletins based on their file creation date
  44. '  CHKTREMAIN 41008   Set up to log off if time exceeded
  45. '  COMMINFO   44000+  Get users baud rate and parity in a string format
  46. '  COMPDATE   59200+  Produces a computational data from YY, MM, DD
  47. '  CONVDIRS   58950   Checks for U & A (shorthand) and converts appropriately
  48. '  CTLINES    58160   Count categories a file can be classified into
  49. '  CTNEWFILES 58150   Check for number of files uploaded after a specific date
  50. '  DELAYIT    50500   Wait number of seconds specified before returning
  51. '  DISPCALL   57001   Display callers file
  52. '  DISPLAYTR  41010+  Compute and display time remaining
  53. '  DISUPDIR   58170   Display the shared directory of the FMS mng. sys.
  54. '  EXPDATE    52000+  Calculate registration expiration date
  55. '  FAKEXRPT   62650   Write out file transfer report for protocols that don't
  56. '  FILELOCK   21995   Allow files to be shared among multiple RBBS-PC's
  57. '  FINDEND    58770   Find where a "word" ends
  58. '  FINDFILE   58790   Determine whether a file exists without opening it
  59. '  FINDFUNC   30600   Handle local keyboard's function & SYSOP's keys
  60. '  FINDLAST   58600   Finds last occurence of a string in a string
  61. '  FINDTIME   58050   Calculate the number of seconds since midnight
  62. '  FMS        58200   Search the upload management system for entries
  63. '  GETALL     59780   Get list of all directories to display
  64. '  GETDIRS    58900   Prompts for directories for file list/new/search cmds
  65. '  GETMATTR   62530   Restore attributes of original message
  66. '  GETYMD     59200   Pulls YY, MM, or DD from a 2 byte stored date
  67. '  GRAPHIC    43031   Determines whether graphic version of file exists
  68. '  HASHRBBS   58080   "Hash" to a user's record in the USERS file
  69. '  INITFMS    58160+  Initialize the RBBS-PC's File Management System
  70. '  INITIBM    30000   Open/create NETBIOS semaphore file
  71. '  INSCOMMA   58130   Format commands in the command prompt
  72. '  LOADNEW    58140   Find the latest uploads
  73. '  LOGDOWN    59400   Records download in private directory
  74. '  MIMPORT    59700   Allow local user to import a text file to a message
  75. '  MODEMPUT   52070   Write a modem command string to the modem
  76. '  MUZAK      59100   Play musical themes for different RBBS functions
  77. '  OPENMSG    30500   Open the messages file as file number 1
  78. '  PAGEUP     33202   Display user info. on local screen for SYSOP
  79. '  PERSFILE   59300   View and select personal files for downloading
  80. '  PROTOCOL   62600   Determine if external protocols are available
  81. '  PUTMATTR   62520   Save attributes of original message
  82. '  READPROF   44000   Read user's profile on return from a "door"
  83. '  REMOVE     58210   Remove characters from within strings
  84. '  ROTORSDIR  58700   Searches for a file using list of subdirs
  85. '  SAVEPROF   43070   Save the user's provile when exiting to "doors" or DOS
  86. '  SETABORT   58750   Set time for a process to abort
  87. '  SETECHO    59600   Set RBBS properly for who is to echo
  88. '  SETOPTS    58100   Set correct prompt line for each subsystem
  89. '  SRTSTRNG   58120   Sort characters in a string
  90. '  SUBMENU    59500   Processes options that have sub-menus
  91. '  TIMEDOUT   63000   Write timed exit .BAT file to RCTTY.BAT
  92. '  TIMEREMAIN 41010   Compute time remaining in minutes
  93. '  TRANSFER   62620   RBBS-PC support for external protocols for file transfer
  94. ' TWOBYTEDATE 59200   Reduces a data to 2 byte string for space compression
  95. '  USERFACE   59450   Processes programmable user interface
  96. '  VIEWARC    64600   Display .ARC file contents to user
  97. '  WIPELINE   58800   Wipes away a line so next prints in its place
  98. '  WORDWRAP   59700+  Adjust a message --wrap linesand perserve paragraphs
  99. '  XFRETURN   62629   Private door exit routine
  100. '
  101. '  $INCLUDE: 'RBBS-VAR.BAS'
  102. '
  103. * ------[ first line different ]------
  104. '
  105. ' $SUBTITLE: 'CHECKRATIO - subroutine to print ul/dl ratio'
  106. ' $PAGE
  107. '
  108. '  SUBROUTINE NAME    -- CHECKRATIO
  109. '
  110. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  111. '                          TELL.USER          TELL USER ABOUT THEIR RATIO
  112. '                          DOWNLOADS          FILES DOWNLOADED
  113. '                          DLBYTES!           BYTES DOWNLOADED
  114. '                          UPLOADS            FILES UPLOADED
  115. '                          ULBYTES!           BYTES UPLOADED
  116. '
  117. '  OUTPUT PARAMETERS  -- OK  - IF IT IS OK FOR THE USER TO DOWNLOAD
  118. '
  119. '  SUBROUTINE PURPOSE -- TO PRINT THE USERS UPLOAD TO DOWNLOAD RATIO
  120. '                        AND TO DETERMINE IF THE USERS HAS VIOLATED
  121. '                        THEIR UPLOAD TO DOWNLOAD RESTRICTION
  122. '
  123. '
  124.       SUB CHECKRATIO (TELL.USER) STATIC                                 'RATIO
  125.       OK = TRUE                                                         'RATIO
  126. '
  127. '   PRINT THE CALLERS UPLOAD AND DOWNLOAD STATISTICS
  128. '
  129. * INSERTING new line(s)
  130. * INSERTING new line(s)
  131. 20096 CHANGE.COLOR = FALSE                                              'COLOR
  132.       A$ = "You uploaded" + STR$(UPLOADS) + " file(s) containing" + _   'RATIO
  133.      STR$(ULBYTES!) + " bytes"                                      'RATIO
  134.       SUBROUTINE.PARAMETER = 1                                          'RATIO
  135.       CALL TPUT                                                         'RATIO
  136.       A$ = "You downloaded" + STR$(DOWNLOADS) + " file(s) containing"+_ 'RATIO
  137.      STR$(DLBYTES!) + " bytes"                                      'RATIO
  138.       SUBROUTINE.PARAMETER = 5                                          'RATIO
  139.       CALL TPUT                                                         'RATIO
  140.       A$ = "Today you downloaded" + STR$(DL.TODAY!) + " file(s)" + _    'RATIO
  141.         " containing" + STR$(BYTES.TODAY!) + " bytes"               'RATIO
  142.       SUBROUTINE.PARAMETER = 5                                          'RATIO
  143.       CALL TPUT                                                         'RATIO
  144.       CALL SKIPLINE (1)                                                 'RATIO
  145.       CHANGE.COLOR = TRUE                                               'COLOR
  146.       A$ = "Your average upload to download ratio is:"                  'RATIO
  147.       SUBROUTINE.PARAMETER = 5                                          'RATIO
  148.       CALL TPUT                                                         'RATIO
  149. '
  150. ' DETERMINE METHOD OF RATIO CHECKING TO BE PERFORMED
  151. '
  152. 20097 IF BYTE.METHOD = 1 THEN                                           'RATIO
  153.      METHOD$ = "byte(s)"                                            'RATIO
  154.      UL.WORK# = ULBYTES!                                            'RATIO
  155.      DL.WORK# = DLBYTES!                                            'RATIO
  156.       ELSEIF BYTE.METHOD = 0 THEN                                       'RATIO
  157.      METHOD$ = "file(s)"                                            'RATIO
  158.      UL.WORK# = UPLOADS                                             'RATIO
  159.      DL.WORK# = DOWNLOADS                                           'RATIO
  160.       ELSEIF BYTE.METHOD = 2 THEN                                       'RATIO
  161.      METHOD$ = " files"                                             'RATIO
  162.      UL.WORK# = UPLOADS                                             'RATIO
  163.      DL.WORK# = DOWNLOADS                                           'RATIO
  164.      TODAY# = RATIO.RESTRICTON# - DL.TODAY!                         'RATIO
  165.       ELSEIF BYTE.METHOD = 3 THEN                                       'RATIO
  166.      METHOD$ = " bytes"                                             'RATIO
  167.      UL.WORK# = ULBYTES!                                            'RATIO
  168.      DL.WORK# = DLBYTES!                                            'RATIO
  169.      TODAY# = RATIO.RESTRICTON# - BYTES.TODAY! - NUM.DNLD.BYTS!     'RATIO
  170.       END IF                                                            'RATIO
  171.  
  172. '
  173. '   PRINT THE USERS UPLOAD TO DOWNLOAD RATIO
  174. '
  175. 20098 IF UL.WORK# <> 0 AND DL.WORK# <> 0 THEN                           'RATIO
  176.      IF UL.WORK# > DL.WORK# THEN                                    'RATIO
  177.         UL.RATIO# = INT((((UL.WORK# / DL.WORK#)+.5)*10)/10)         'RATIO
  178.         DL.RATIO# = 1                                               'RATIO
  179.         XFER.RATIO# = 0                                             'RATIO
  180.      ELSE                                                           'RATIO
  181.         UL.RATIO# =1                                                'RATIO
  182.         DL.RATIO# = DL.WORK# / UL.WORK#                             'RATIO
  183.         XFER.RATIO# = DL.RATIO#                                     'RATIO
  184.      END IF                                                         'RATIO
  185.      DL.RATIO# = INT(((DL.RATIO#+.5)*10)/10)                        'RATIO
  186.       ELSE                                                              'RATIO
  187.      DL.RATIO# = DL.WORK#                                           'RATIO
  188.      UL.RATIO# = UL.WORK#                                           'RATIO
  189.      IF UL.WORK# = 0 THEN                                           'RATIO
  190.         XFER.RATIO# = RATIO.RESTRICTON#                             'RATIO
  191.      ELSE                                                           'RATIO
  192.         XFER.RATIO# = DL.RATIO#                                     'RATIO
  193.      END IF                                                         'RATIO
  194.       END IF                                                            'RATIO
  195. 20099 A$ = STR$(UL.RATIO#) + " " + METHOD$ + " uploaded for every" + _  'RATIO
  196.        STR$(DL.RATIO#) + " " + METHOD$ + " downloaded"              'RATIO
  197.       SUBROUTINE.PARAMETER = 5                                          'RATIO
  198.       CALL TPUT                                                         'RATIO
  199.       CALL SKIPLINE (1)                                                 'RATIO
  200. '
  201. '  CHECK TO SEE IF THE USERS HAS VIOLATED THEIR UL/DL RESTRICTION
  202. '
  203. 20100 IF RATIO.RESTRICTON# AND TELL.USER THEN                           'RATIO
  204.      IF BYTE.METHOD > 1 THEN                                        'RATIO
  205.         IF TODAY# <= 0 THEN                                         'RATIO
  206.            A$ = "You have reached you limit of" + _                 'RATIO
  207.             STR$(RATIO.RESTRICTON#) + METHOD$ + " per day. "+_  'RATIO
  208.             "Try again tomorrow." + _                           'RATIO
  209.             CHR$(7)                                             'RATIO
  210.            OK = FALSE                                               'RATIO
  211.         ELSE                                                        'RATIO
  212.            A$ = "You can download" + STR$(TODAY#) + _               'RATIO
  213.             " more" + METHOD$ + " for today."                   'RATIO
  214.            OK = TRUE                                                'RATIO
  215.         END IF                                                      'RATIO
  216.         SUBROUTINE.PARAMETER = 5                                    'RATIO
  217.         CALL TPUT                                                   'RATIO
  218.         CALL SKIPLINE(1)                                            'RATIO
  219.         EXIT SUB                                                    'RATIO
  220.      END IF                                                         'RATIO
  221.       END IF                                                            'RATIO
  222. '
  223. '
  224. '
  225.       IF RATIO.RESTRICTON# AND TELL.USER THEN                           'RATIO
  226.      IF XFER.RATIO# => RATIO.RESTRICTON#  THEN                      'RATIO
  227.         OK = FALSE                                                  'RATIO
  228.         CHANGE.COLOR = FALSE                                        'COLOR
  229.         A$ = "Your upload to download ratio is too low to download!"'RATIO
  230.         SUBROUTINE.PARAMETER = 5                                    'RATIO
  231.         CALL TPUT                                                   'RATIO
  232.         A$ = "You must upload at least" + _                         'RATIO
  233.          STR$(INT(((DL.WORK# - (UL.WORK# * RATIO.RESTRICTON#)) _'RATIO
  234.          / RATIO.RESTRICTON#) + 1)) + _                         'RATIO
  235.          + " " + METHOD$ + " before you can download!" + CHR$(7)'RATIO
  236.      ELSE                                                           'RATIO
  237.         A$ = "You can download" + _                                 'RATIO
  238.          STR$(INT((UL.WORK# * RATIO.RESTRICTON#)-DL.WORK#)) + _ 'RATIO
  239.          " " + METHOD$ + " before you need to upload"           'RATIO
  240.      END IF                                                         'RATIO
  241.      SUBROUTINE.PARAMETER = 5                                       'RATIO
  242.      CALL TPUT                                                      'RATIO
  243.      CALL SKIPLINE (1)                                              'RATIO
  244.       END IF                                                            'RATIO
  245. 20101 CHANGE.COLOR = TRUE                                               'COLOR
  246.       END SUB                                                           'RATIO
  247. '
  248. '
  249. ' $SUBTITLE: 'FILELOCK - subroutine to share RBBS-PC files'
  250. ' $PAGE
  251. '
  252. '  SUBROUTINE NAME    -- FILELOCK
  253. '
  254. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  255. '                        SUBROUTINE.PARAMETER = 1 UNLOCK USERS AND MESSAGES
  256. '                                               2 FLUSH MESSAGE RECORD TO DISK
  257. '                                                 AND UNLOCK MESSAGES
  258. '                                               3 LOCK MESSAGE FILE
  259. '                                               4 UNLOCK MESSAGE FILE
  260. '                                               5 LOCK USER FILE
  261. '                                               6 LOCK 4 RECORD BLOCK IN USER
  262. '                                                 FILE
  263. '                                               7 UNLOCK USER FILE
  264. '                                               8 UNLOCK 4 RECORD BLOCK IN USER
  265. '                                                 FILE
  266. '                                               9 LOCK UPLOAD DIRECTORY OR
  267. '                                                 COMMENTS FILE
  268. '                                              10 UNLOCK UPLOAD DIRECTORY OR
  269. '                                                 COMMENTS FILE
  270. '                        ACTIVE.MESSAGE FILE$   NAME OF MESSAGE FILE
  271. '                        ACTIVE.USER.FILE$      NAME OF USER FILE
  272. '                        CONFIG.FILE.NAME$      FILE NAME TO FLUSH RECORD FROM
  273. '                        EN$                    UPLOAD DIRECTORY OR COMMENTS
  274. '                                               FILE NAME TO LOCK/UNLOCK
  275. '                        NETWORK.TYPE           TYPE OF NETWORK LOCKING TO USE
  276. '
  277. '  OUTPUT PARAMETERS  -- SUBROUTINE.PARAMETER = -1 TERMINATE RBBS-PC IMMEDATELY
  278. '                        BLK
  279. '                        LOCK.DRIVE
  280. '                        LOCK.FILE.NAME$
  281. '                        LOCK.STATUS$
  282. '                        MESSAGE.FILE.LOCK
  283. '                        USER.BLOCK.LOCK
  284. '                        USER.FILE.LOCK
  285. '                        USER.FILE.INDEX
  286. '
  287. '  SUBROUTINE PURPOSE -- TO LOCK AND UNLOCK THE SHARED RBBS-PC FILES WHEN
  288. '                        MULTIPLE COPIES OF RBBS-PC ARE SHARING THE SAME
  289. '                        FILES IN EITHER A MULTI-TASKING DOS ENVIRONMENT OR
  290. '                        IN A LOCAL AREA NETWORK ENVIRONMENT
  291.       SUB FILELOCK STATIC
  292.       ON SUBROUTINE.PARAMETER GOSUB 21995,21996,22000,25000,26000, _
  293.                                     26500,27000,27500,29000,29500
  294.       EXIT SUB
  295. '
  296. ' *****************************************************************************
  297. ' *  UNLOCK USERS AND MESSAGES                                                *
  298. ' *****************************************************************************
  299. '
  300. * REPLACING old line(s) by new
  301. 33990 SUB PAGEUP STATIC
  302.       CALL LPRNT (" ",1)
  303.       CALL LPRNT ("USER NAME : " + ACTIVE.USER.NAME$,1)
  304.       CALL LPRNT ("SECURITY  :" + STR$(USER.SECURITY.SAVE),1)
  305.       CALL LPRNT ("PASSWORD  :" + PASSWORD.SAVE$,1)
  306.       CALL LPRNT ("READ MSG. :" + STR$(LAST.MESSAGE.READ),1)
  307.       CALL LPRNT ("TIMES ON  :" + STR$(TIMES.LOGGED.ON),1)
  308.       CALL LPRNT ("LAST ON   :" + LAST.DATE.TIME.ON.SAVE$,1)
  309.       CALL LPRNT ("DOWNLOADS :" + STR$(DOWNLOADS),1)
  310.       CALL LPRNT ("UPLOADS   :" + STR$(UPLOADS),1)
  311. * ------[ first line different ]------
  312.       CALL LPRNT ("DL-BYTES  :" + STR$(DLBYTES!),1)                    'RATIO
  313.       CALL LPRNT ("UL-BYTES  :" + STR$(ULBYTES!),1)                    'RATIO
  314.       IF RESTRICT.BY.DATE THEN _
  315.          CALL LPRNT ("EXPIRATION: " + EXPIRATION.DATE$,1)
  316.       CALL LPRNT ("User's Profile",1)
  317.       END SUB
  318. ' $SUBTITLE: 'CHKTREMAIN - Kicks off if no time remaining'
  319. ' $PAGE
  320. '
  321. '  SUBROUTINE NAME    -- CHKTREMAIN
  322. '
  323. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  324. '                         TIME.LEFT!
  325. '  OUTPUT PARAMETERS  --     PARAMETER                    MEANING
  326. '                         TIME.LEFT!      TIME IN MINUTES LEFT IN SESSION
  327. '                         TCA!            TIME USED IN SECONDS
  328. '                         SUBROUTINE.PARAMETER   -1 if no time left
  329.       SUB CHKTREMAIN (TIME.LEFT!) STATIC
  330. * REPLACING old line(s) by new
  331.